MacTech 1 to 12/MacTech-vol-1-12.toast/Source/MacTech® Magazine/Volume 06 - 1990/06.10 Oct 90/LZW Source/lDecomp.p

Text File | 1989-05-07 | 18.2 KB | 693 lines | [TEXT/MPS ]

{$R-}
{$DEFC DEBUG}
{$SETC DEBUG=TRUE}
PROGRAM LDecomp;

{ Adaptive LZW decompression }

USES
    MemTypes,
    QuickDraw,
    OSIntf,
    ToolIntf,
    PackIntf;

CONST
    maxBuff = 8192;        {i/o buffer size}
    tableSize = 16383;    {Table size minus 1, 14 bits for 0-based array}
    noPrev = $7FFF;        {First entry in chain}
    eofChar = -2;        {Got to end of input file}
    endList = -1;        {End of chain}
    empty = -3;            {Table entry is unused}
    clearCode = 256;    {Reserved code signalling adaptive reset}
    maxStack = 4096;    {Handles up to 16MB repetition before overflow}

TYPE
    {With some older compilers, you'll need to break the following into
     multiple arrays since they won't allow data structure definitions
     larger than 32K bytes}
    StringTableEntry = RECORD
        prevChar: Integer;
        followingByte: Integer;
        next: Integer;
        used: Boolean;
        reserved: Boolean;
    END;
    StringTableArray = ARRAY [0..tableSize] OF StringTableEntry; {128K structure unless packed}
    StringTablePtr = ^StringTableArray;

    IntPtr = ^Integer;
    Buffer = PACKED ARRAY [1..maxBuff] OF Char;
    BufPtr = ^Buffer;
    HeaderRecord = RECORD
        name: String[31];
        dfSize: LongInt;
        rfSize: LongInt;
        fndrInfo: FInfo;
    END;
    StackType = ARRAY [1..maxStack] OF Integer;
    StkPtr = ^StackType;
    Remainder = (none, sixBit, fourBit, twoBit);

VAR
    inRef: Integer;            {File reference number of the input file}
    outRef: Integer;        {File reference number of the output file}
    outVRefNum: Integer;    {Volume/WD reference number of output file}
    eofSignal: Boolean;
    inBufSize: Integer;        {Count of characters in the input buffer }
    inputPos: Integer;        {Current position in the input buffer}
    outputPos: Integer;        {Current position in the output buffer}
    bytesRead: LongInt;        {Total bytes read from input file}
    bytesWritten: LongInt;    {Total bytes written to output file}
    bytesInBuffer: LongInt;    {Number of bytes read into input buffer at last attempt}
    inputBuffer: BufPtr;    {Where we read the compressed data}
    outputBuffer: BufPtr;    {Where we write the uncompressed data}

    stringTable: StringTablePtr;    {Pointer to memory structure}
    outfileName: Str255;    {Name of file that we're recreating}
    tableUsed: Integer;        {How many entries currently in string table}
    inputCode: Integer;        {The 14-bit code that we're working on}
    carryOver: Remainder;    {How many bits are to be prepended to next input byte}
    doingDFork: Boolean;    {Flag to tell which fork of the file we're decompressing}
    fsErr: OSErr;            {For file system calls}
    dataForkSize: LongInt;    {Size of data fork we will decompress}
    rsrcForkSize: LongInt;    {Size of resource fork we will decompress}
    progWindow: WindowPtr;    {Window for debugging/progress information}
    boundsRect: Rect;        {Rectangle for creating progress window}
    stackPointer: Integer;    {Index into decode stack array}
    stack: StkPtr;            {Pointer into decode stack array}
    hdrRec: HeaderRecord;    {Our header that tells about the file we're decompressing}

    PROCEDURE _DataInit; EXTERNAL;    {Comment this out for THINK Pascal}


    PROCEDURE FileAlert(str: Str255);

    CONST
        fsAlert =    1111;

    VAR
        item: Integer;

    BEGIN
        ParamText(str, '', '', '');
        item := StopAlert(fsAlert, NIL);
        fsErr := FSClose(inRef);
        fsErr := FSClose(outRef);
        fsErr := FlushVol(NIL, outVRefnum);
        ExitToShell;
    END {FileAlert} ;


{$IFC DEBUG}
    PROCEDURE DebugAlert(l1, l2: LongInt);

    CONST
        dbgAlert = 1112;

    VAR
        s1, s2: Str255;
        item: Integer;

    BEGIN
        NumToString(l1, s1);
        NumToString(l2, s2);
        ParamText(s1, s2, '', '');
        item := NoteAlert(dbgAlert, NIL);
    END {DebugAlert} ;
{$ENDC}


    PROCEDURE ShowProgress;

    VAR
        savePort: GrafPtr;
        aStr: Str255;

    BEGIN
        GetPort(savePort);
        SetPort(progWindow);
        EraseRect(progWindow^.portRect);
        NumToString(bytesWritten, aStr);
        MoveTo(5, 10);
        DrawString(aStr);
        NumToString(bytesRead, aStr);
        MoveTo(5, 25);
        DrawString(aStr);
        NumToString(tableUsed, aStr);
        MoveTo(5, 40);
        DrawString(aStr);
        SetPort(savePort);
    END {ShowProgress} ;


    FUNCTION HashIt(prevC, follC: Integer): Integer;
    {You can come up with much better hash functions, just make sure that both
     the compression and decompression programs use the same one.}

    VAR
        temp,
        local: LongInt;

    BEGIN
        {local := BOR((prevC+follC), $00008000);
        temp := local * local;
        local := BAND(BSR(temp, 7), tableSize);}
        HashIt := BAND(BXOR(BSL(prevC, 5), follC), tableSize);
    END {HashIt} ;


    FUNCTION GetHashCode(prevC, follC: Integer): Integer;
    {    Return value is the hash code for <w>c string }

    VAR
        index: Integer;
        index2: Integer;

    BEGIN
        index := HashIt(prevC, follC);

        {If the entry isn't already used we have a hash code}
        IF (stringTable^[index].used) THEN BEGIN
            {Entry already used, skip to end of collision list}
            WHILE stringTable^[index].next <> endList DO
                index := stringTable^[index].next;
            {Begin a linear probe down a bit from last entry in the collision list}
            index2 := BAND(index + 101, tableSize);
            {Look for an unused entry using linear probing}
            WHILE stringTable^[index2].used DO
                index2 := BAND(Succ(index2), tableSize);
            {Point the previous end of collision list at this new node}
            stringTable^[index].next := index2;
            GetHashCode := index2;
        END ELSE GetHashCode := index;
    END {GetHashCode} ;


    PROCEDURE MakeTableEntry(prevC, follC: Integer);
    {We could put the conditional test before each call to MakeTableEntry
     instead of inside the routine}

    VAR
        aCode: Integer;

    BEGIN
        IF tableUsed <= tableSize THEN BEGIN
            aCode := GetHashCode(prevC, follC);
            WITH stringTable^[aCode] DO BEGIN
                used := true;
                next := endList;
                prevChar := prevC;
                followingByte := follC;
            END;

            tableUsed := tableUsed + 1;
        END;
    END {MakeTableEntry} ;


    FUNCTION LookupString(prevC, follC: Integer): Integer;

    VAR
        index: Integer;
        found: Boolean;

    BEGIN
        index := HashIt(prevC, follC);
        LookupString := endList;
        found := FALSE;
        {    Search list of collision entries for one that matches <w>c }
        REPEAT
            IF (stringTable^[index].prevChar = prevC) &
                (stringTable^[index].followingByte = follC) THEN found := true
            ELSE index := stringTable^[index].next;
        UNTIL found OR (index = endList);
        { Return index if <w>c found, endList otherwise }
        IF found THEN LookupString := index;
    END {LookupString} ;


    PROCEDURE GetByte(VAR c: Integer);
    {    -- Read a character from the input file.  Make sure the compiler doesn't sign
        -- extend anything.
        -- Parameter
        --    c    output
        -- Globals affected
        --    inputPos, bytesInBuffer, inputBuffer^ (global because no statics in Pascal)
        --    bytesRead                    }

    VAR
        count: LongInt;
        error: OSErr;

    BEGIN
        inputPos := inputPos + 1;
        {    This will force a read the first time through and every time after that
            where inputPos has "cycled back" to 0 }
        IF inputPos > bytesInBuffer THEN BEGIN
            bytesInBuffer := maxBuff;
            error := FSRead(inRef, bytesInBuffer, Ptr(inputBuffer));
            inputPos := 1;
        END;
        IF bytesInBuffer = 0 THEN BEGIN
            c := eofChar;
            eofSignal := true;
        END ELSE BEGIN
            bytesRead := bytesRead + 1;
            c := Ord(inputBuffer^[inputPos]);
        END;
    END {GetByte} ;


    PROCEDURE PutByte(c: Integer);

    VAR
        count: LongInt;
        error: OSErr;

    BEGIN
        IF outputPos = maxBuff THEN BEGIN
            count := maxBuff;
            error := FSWrite(outRef, count, Ptr(outputBuffer));
            outputPos := 0;
            ShowProgress;
        END;
        IF doingDFork AND (bytesWritten >= dataForkSize) AND (NOT eofSignal) THEN BEGIN
            doingDFork := false;
            dataForkSize := bytesWritten;
            IF outputPos > 0 THEN BEGIN
                count := outputPos;
                error := FSWrite(outRef, count, Ptr(outputBuffer));
            END;
            error := SetEOF(outRef, bytesWritten);
            outputPos := 0;
            error := FSClose(outRef);
            IF rsrcForkSize > 0 THEN BEGIN
                {only need to open it if we have something to write}
                error := OpenRF(outfileName, outVRefNum, outRef);
                IF error <> noErr THEN FileAlert('Error opening resource fork');
                error := SetFPos(outRef, fsFromStart, 0);
            END;
        END;
        outputPos := outputPos + 1;
        outputBuffer^[outputPos] := Chr(c);
        bytesWritten := bytesWritten + 1;
    END {PutByte} ;


    PROCEDURE InitStrTable;

    VAR
        i: Integer;

    BEGIN
        tableUsed := 0;
        FOR i := 0 TO tableSize DO
            WITH stringTable^[i] DO BEGIN
                prevChar := noPrev;
                followingByte := noPrev;
                next := -1;
                used := false;
                reserved := false;
            END;
        {Enter all single ascii characters into the string table}
        FOR i := 0 TO clearCode DO
            MakeTableEntry(noPrev, i);
    END {InitStrTable} ;


    PROCEDURE Initialize;

        PROCEDURE InitManagers;

        BEGIN
            MaxApplZone;
            InitGraf(@thePort);
            InitFonts;
            FlushEvents(everyEvent, 0);
            InitWindows;
            InitMenus;
            TEInit;
            InitDialogs(NIL);
            InitCursor;
            UnLoadSeg(@_DataInit);    {MPW-specific unload, comment out for THINK Pascal}
        END {InitManagers} ;

    BEGIN
        InitManagers;

        inputBuffer := BufPtr(NewPtr(SizeOf(Buffer)));
        IF inputBuffer = NIL THEN ExitToShell;
        outputBuffer := BufPtr(NewPtr(SizeOf(Buffer)));
        IF outputBuffer = NIL THEN ExitToShell;
        stringTable := StringTablePtr(NewPtr(SizeOf(StringTableArray)));
        IF stringTable = NIL THEN ExitToShell;

        inputPos := 0;
        outputPos := 0;
        inBufSize := 0;
        bytesRead := 0;
        bytesWritten := 0;
        bytesInBuffer := 0;
        doingDFork := true;
        inputCode := empty;
        carryOver := none;

        InitStrTable;
    END {Initialize} ;


    PROCEDURE GetTopLeft({using} dlogID: Integer;
                         {returning} VAR where: Point);
    {    —    Return the point where DLOG(dlogID) should have its top-left corner so as
        —    to be centered in the area below the menubar of the main screen.  The
        —    centering is horizontal, vertically it should be one-third of the way.  This
        —    is achieved by getting the DLOG resource and centering its rectangle within
        —    screenBits.bounds after adjusting screenBits.bounds by mBarHeight. }

    CONST
        {Probably should use Script Mgr. routine, GetMBarHeight, instead}
        mBarHeight = $0BAA;    {Address of global integer containing menu bar height}

    VAR
        screenRect,
        dlogRect:    Rect;
        mBarAdjustment: IntPtr;
        aDlog: DialogTHndl;

    BEGIN
        screenRect := screenBits.bounds;
        mBarAdjustment := IntPtr(mBarHeight);
        screenRect.top := screenRect.top + mBarAdjustment^;
        aDlog := DialogTHndl(GetResource('DLOG', dlogID));
        DetachResource(Handle(aDlog));
        dlogRect := aDlog^^.boundsRect;
        WITH screenRect DO BEGIN
            where.v := ((bottom - top) - (dlogRect.bottom - dlogRect.top)) DIV 3;
            where.h := ((right - left) - (dlogRect.right - dlogRect.left)) DIV 2;
        END;
    END {GetTopLeft};


    FUNCTION GetInputFile({returning} VAR refNum: Integer): Boolean;
    {    —    Return false if the user cancels, the request, true otherwise.  If a file
        —    is selected for compression, open the file and pass back the refnum.
        —    The constant getDlgID is from PackIntf.
        —    Global side-effects of this routine include the initialization of a number
        —    of fields of the hdrRec global and the setting of the inVRefNum global.}

    CONST
        allFiles = -1;

    VAR
        tl: Point;
        reply: SFReply;
        typeList: SFTypeList;
        anErr,
        error: OSErr;
        finderInfo: FInfo;
        count: LongInt;
        dtRec: DateTimeRec;

    BEGIN
        GetTopLeft(getDlgID, tl);
        {typeList doesn't need to be initialized since we're asking for all files with the -1}
        SFGetFile(tl, '', NIL, allFiles, typeList, NIL, reply);
        IF reply.good THEN BEGIN
            error := FSOpen(reply.fName, reply.vRefnum, refNum);
            IF error = noErr THEN error := SetFPos(refNum, fsFromStart, 0)
            ELSE anErr := FSClose(refNum);
            IF error = noErr THEN BEGIN
                GetInputFile := true;
                count := SizeOf(HeaderRecord);
                error := FSRead(refNum, count, @hdrRec);
                IF error = noErr THEN BEGIN
                    dataForkSize := hdrRec.dfSize;
                    rsrcForkSize := hdrRec.rfSize;
                END ELSE BEGIN
                    anErr := FSClose(refNum);
                    GetInputFile := false;
                END;
            END ELSE GetInputFile := false;
        END ELSE GetInputFile := false;
    END {GetInputFile} ;


    FUNCTION GetOutputFile({returning} VAR refNum: Integer): Boolean;

    VAR
        tl: Point;
        reply: SFReply;
        error: OSErr;
        count: LongInt;

    BEGIN
        GetTopLeft(putDlgID, tl);
        SFPutFile(tl, '', hdrRec.name, NIL, reply);
        IF reply.good THEN BEGIN
            outfileName := reply.fName;
            error := FSOpen(reply.fName, reply.vRefnum, refNum);
            IF error <> noErr THEN BEGIN    {File didn't already exist, need to create it}
                error := Create(reply.fName, reply.vRefnum,
                                hdrRec.fndrInfo.fdCreator, hdrRec.fndrInfo.fdType);

                IF error = noErr THEN
                    IF hdrRec.dfSize > 0 THEN
                        error := FSOpen(reply.fName, reply.vRefnum, refNum)
                    ELSE BEGIN
                        error := OpenRF(reply.fName, reply.vRefNum, refNum);
                        doingDFork := false;
                    END;
                IF error = noErr THEN error := SetFPos(refNum, fsFromStart, 0);
            END;
            IF error = noErr THEN BEGIN
                GetOutputFile := true;
                outVRefNum := reply.vRefnum;
            END ELSE GetOutputFile := false;
        END ELSE GetOutputFile := false;
    END {GetOutputFile} ;


    PROCEDURE Terminate;

    VAR
        count: LongInt;

    BEGIN
        ShowProgress;
        IF outputPos > 0 THEN BEGIN
            count := outputPos;
            fsErr := FSWrite(outRef, count, Ptr(outputBuffer));
            IF fsErr = noErr THEN BEGIN
                IF doingDFork THEN BEGIN
                    dataForkSize := bytesWritten;
                    fsErr := SetEOF(outRef, dataForkSize);
                END ELSE IF rsrcForkSize > 0 THEN BEGIN
                    rsrcForkSize := bytesWritten - dataForkSize;
                    fsErr := SetEOF(outRef, rsrcForkSize);
                END;
                IF fsErr <> noErr THEN FileAlert('SetEOF Error in Terminate');
            END ELSE FileAlert('Write Error in Terminate');
        END;
        fsErr := FSClose(outRef);
        fsErr := FlushVol(NIL, outVRefNum);
        fsErr := FSClose(inRef);
    END {Terminate} ;


    PROCEDURE GetCode(VAR hashCode: Integer);

    VAR
        localBuf, localBuf2: Integer;

    BEGIN
        CASE carryOver OF
            none:    {get two bytes and return 14 ms bits, carry over two least}
                BEGIN
                    GetByte(localBuf);
                    IF (localBuf = eofChar) THEN BEGIN
                        hashCode := eofChar;
                        Exit(GetCode);
                    END;
                    GetByte(inputCode);
                    IF (inputCode = eofChar) THEN BEGIN
                        hashCode := eofChar;
                        Exit(GetCode);
                    END;
                    hashCode := BAND(BSL(localBuf, 6), $3FC0) +
                                BAND(BSR(inputCode, 2), $003F);
                    inputCode := BAND(inputCode, $0003);
                    carryOver := twoBit;
                END;

            twoBit:    {have two bits, get two bytes, return 14 ms bits, save 4 ls bits}
                BEGIN
                    GetByte(localBuf);
                    IF (localBuf = eofChar) THEN BEGIN
                        hashCode := eofChar;
                        Exit(GetCode);
                    END;
                    GetByte(localBuf2);
                    IF (localBuf2 = eofChar) THEN BEGIN
                        hashCode := eofChar;
                        Exit(GetCode);
                    END;
                    hashCode := BAND(BSL(inputCode, 12), $3000) +
                                BAND(BSL(localBuf, 4), $0FF0) +
                                BAND(BSR(localBuf2, 4), $000F);
                    inputCode := BAND(localBuf2, $000F);
                    carryOver := fourBit;
                END;

            fourBit: {Have four bits, get two bytes, return 14 ms bits, save 6 ls bits}
                BEGIN
                    GetByte(localBuf);
                    IF (localBuf = eofChar) THEN BEGIN
                        hashCode := eofChar;
                        Exit(GetCode);
                    END;
                    GetByte(localBuf2);
                    IF (localBuf2 = eofChar) THEN BEGIN
                        hashCode := eofChar;
                        Exit(GetCode);
                    END;
                    hashCode := BAND(BSL(inputCode, 10), $3C00) +
                                BAND(BSL(localBuf, 2), $03FC) +
                                BAND(BSR(localBuf2, 6), $0003);
                    inputCode := BAND(localBuf2, $003F);
                    carryOver := sixBit;
                END;

            sixBit:    {have six bits, get a byte, return the 14 bits, carry nothing}
                BEGIN
                    GetByte(localBuf);
                    IF (localBuf = eofChar) THEN BEGIN
                        hashCode := eofChar;
                        Exit(GetCode);
                    END;
                    hashCode := BAND(BSL(inputCode, 8), $3F00) +
                                BAND(localBuf, $00FF);
                    inputCode := empty;
                    carryOver := none;
                END;
        END;
    END {GetCode} ;


    PROCEDURE Push(c: Integer);

    BEGIN
        stackPointer := stackPointer + 1;
        stack^[stackPointer] := c;

        IF (stackPointer >= maxStack) THEN BEGIN
            {If this happens, you've typed something in wrong -- would take
             a degenerate case of over 16MB in size to do so otherwise}
            FileAlert('***STACK OVERFLOW***');
        END;
    END {Push} ;


    PROCEDURE Pop(VAR c: Integer);

    BEGIN
        IF stackPointer > 0 THEN BEGIN
            c := stack^[stackPointer];
            stackPointer := stackPointer - 1;
        END ELSE c := empty;
    END {Pop} ;


    PROCEDURE DoDecompression;

    VAR
        c: Integer;
        code: Integer;
        oldCode: Integer;
        finalByte: Integer;
        inCode: Integer;
        lastChar: Integer;
        unknown: Boolean;
        tempC: Integer;
        resetCode: Integer;
        anEvent: EventRecord;

    BEGIN
        {Initialize things and "prime the pump"}
        stackPointer := 0;
        stack := StkPtr(NewPtr(SizeOf(StackType)));
        unknown := false;    {First string is always known as it is a single char}
        resetCode := LookupString(noPrev, clearCode);
        GetCode(oldCode);
        code := oldCode;
        c := stringTable^[code].followingByte;
        PutByte(c);
        finalByte := c;

        {Now, we get down to work}
        GetCode(inCode);
        WHILE inCode <> eofChar DO BEGIN
            code := inCode;
            IF (NOT stringTable^[code].used) THEN BEGIN
                lastChar := finalByte;
                code := oldCode;
                unknown := true;
            END;

            {    Run through code extracting single bytes until no more
                bytes can be removed.  Push these onto the stack.  They
                will be entered in reverse order and will come out in proper
                order when popped. }
            WHILE (stringTable^[code].prevChar <> noPrev) DO
                WITH stringTable^[code] DO BEGIN
                    Push(followingByte);
                    code := prevChar;
                END;

            {    We now have the first byte in the string. }
            finalByte := stringTable^[code].followingByte;
            PutByte(finalByte);
            {    Now pop everything off the stack }
            Pop(tempC);
            WHILE tempC <> empty DO BEGIN
                PutByte(tempC);
                Pop(tempC);
            END;
            {    If the code isn't known, then output the follower byte of
                the last byte in the string. }
            IF unknown THEN BEGIN
                finalByte := lastChar;
                PutByte(finalByte);
                unknown := false;
            END;

            IF GetNextEvent(everyEvent, anEvent) THEN ;
            MakeTableEntry(oldCode, finalByte);
            oldCode := inCode;
            GetCode(inCode);
            IF (inCode = resetCode) THEN BEGIN
                {Compression ratio dropped, time to build a new table}
                InitStrTable;
                GetCode(oldCode);
                c := stringTable^[oldCode].followingByte;
                PutByte(c);
                finalByte := c;
                GetCode(inCode);
            END;
        END;
    END {DoDecompression} ;

BEGIN
    Initialize;
    IF GetInputFile(inRef) THEN
        IF GetOutputFile(outRef) THEN BEGIN
            SetRect(boundsRect, 100, 50, 250, 100);
            progWindow := NewWindow(NIL, boundsRect, 'Bytes Read',
                                    true, noGrowDocProc, Pointer(-1), false, 0);
            DoDecompression;
            Terminate;
{$IFC DEBUG}
            DebugAlert(bytesRead, bytesWritten);
{$ENDC}
        END;
END.